home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / survive / Phonetic / PHON1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-10-22  |  10.2 KB  |  361 lines
  1. unit phon1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, Db, DBTables;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     Memo1: TMemo;
  12.     procedure FormCreate(Sender: TObject);
  13.   private
  14.   public
  15.     procedure ShowValue(aKey: string);
  16.     function Soundex(aKey: string): string;
  17.     function Soundex2(aKey: string): string;
  18.     function Metaphone(aKey: string): string;
  19.   end;
  20.  
  21. var
  22.   Form1: TForm1;
  23.  
  24. implementation
  25.  
  26. {$R *.DFM}
  27.  
  28. function TForm1.Soundex(aKey: string): string;
  29. const           {ABCDEFGHIJKLMNOPQRSTUVWXYZ}
  30.   LetterCodes = '01230120022455012623010202';
  31.   MaxCodeLength = 4;
  32. var
  33.   I: Integer;
  34.   Ch: Char;
  35.   LastCh: Char;
  36. begin
  37.   Result := '';
  38.   LastCh := #0;
  39.   I := 1;
  40.   while Length(Result) <> MaxCodeLength do begin
  41.     if I > Length(aKey) then
  42.       Result := Result + '0'
  43.     else begin
  44.       Ch := UpCase(aKey[I]);
  45.       if Ch in ['A'..'Z'] then
  46.         if Length(Result) = 0 then
  47.           Result := Ch
  48.         else begin
  49.           Ch := LetterCodes[Ord(Ch) - 64];
  50.           if (Ch <> '0') and (Ch <> LastCh) then begin
  51.             Result := Result + Ch;
  52.             LastCh := Ch;
  53.           end;
  54.         end;
  55.       Inc(I);
  56.     end;
  57.   end;
  58. end;
  59.  
  60. function TForm1.Soundex2(aKey: string): string;
  61. { This is an "improved" Soundex algorithm from Joe Celko's "SQL for Smarties",
  62.   1995, Morgan Kaufman Publishers, Inc, pp 85-87. }
  63. const
  64.   Vowels = ['A', 'E', 'I', 'O', 'U'];
  65. var
  66.   I: Integer;
  67.   Ch: Char;
  68.  
  69.   function TransformPrefix(aFind, aReplace: string): Boolean;
  70.   begin
  71.     Result := CompareText(aFind, aKey) = 0;
  72.     if Result then
  73.       Move(aReplace[1], aKey[1], Length(aReplace));
  74.   end;
  75.  
  76.   procedure Transform(aFind, aReplace: string);
  77.   var
  78.     I, J: Integer;
  79.     Match: Boolean;
  80.   begin
  81.     for I := 2 to Length(aKey) - Length(aFind) + 1 do begin
  82.       Match := True;
  83.       for J := 1 to Length(aFind) do
  84.         if aKey[I] <> aFind[J] then begin
  85.           Match := False;
  86.           Break;
  87.         end;
  88.       if Match then
  89.         Move(aReplace[1], aKey[I], Length(aReplace));
  90.     end;
  91.   end;
  92. begin
  93.  
  94.   { first pass: convert to upper, strip non letters, reduce vowels }
  95.   I := 1;
  96.   while I <= Length(aKey) do begin
  97.     Ch := UpCase(aKey[I]);
  98.     if Ch in ['A'..'Z'] then begin
  99.       if Ch in Vowels then
  100.         Ch := 'A';
  101.       aKey[I] := Ch;
  102.       Inc(I);
  103.     end
  104.     else
  105.       Delete(aKey, I, 1);
  106.   end;
  107.  
  108.   { Transform prefixes }
  109.   if not TransformPrefix('MAC', 'MCC') then
  110.     if not TransformPrefix('KN', 'NN') then
  111.       if not TransformPrefix('K', 'C') then
  112.         if not TransformPrefix('PF', 'FF') then
  113.           if not TransformPrefix('SCH', 'SSS') then
  114.             TransformPrefix('PH', 'FF');
  115.  
  116.   { Transform letter combinations }
  117.   Transform('DG', 'GG');
  118.   Transform('CAAN', 'TAAN');
  119.   Transform('D', 'T');
  120.   Transform('NST', 'NSS');
  121.   Transform('AV', 'AF');
  122.   Transform('Q', 'G');
  123.   Transform('Z', 'S');
  124.   Transform('M', 'N');
  125.   Transform('KN', 'NN');
  126.   Transform('K', 'C');
  127.  
  128.   { Replace H with A unless it is surrounded by A }
  129.   I := 2;
  130.   while I <= Length(aKey) do begin
  131.     if aKey[I] = 'H' then
  132.       if aKey[I - 1] <> 'A' then
  133.         if (I < Length(aKey)) and (aKey[I + 1] <> 'A') then
  134.           aKey[I] := 'H'
  135.         else
  136.           Inc(I);  { we know it's A so no need to check for H }
  137.     Inc(I);
  138.   end;
  139.  
  140.   { Replace AW with A }
  141.   I := 2;
  142.   while I < Length(aKey) do begin
  143.     if (aKey[I] = 'A') and (aKey[I + 1] = 'W') then
  144.       Delete(aKey, I + 1, 1);
  145.     Inc(I);
  146.   end;
  147.  
  148.   { Transforms }
  149.   Transform('PH', 'FF');
  150.   Transform('SCH', 'SSS');
  151.  
  152.   { Drop trailing A or S chars }
  153.   I := Length(aKey);
  154.   while (I > 0) and (aKey[I] in ['A', 'S']) do begin
  155.     Delete(aKey, I, 1);
  156.     Dec(I);
  157.   end;
  158.  
  159.   { Transform trailing NT with TT }
  160.   if Copy(aKey, Length(aKey) - 1, 2) = 'NT' then
  161.     aKey := Copy(aKey, 1, Length(aKey) - 2) + 'TT';
  162.  
  163.   { Strip out all but leading A's }
  164.   I := 2;
  165.   while I <= Length(aKey) do
  166.     if aKey[I] = 'A' then
  167.       Delete(aKey, I, 1)
  168.     else
  169.       Inc(I);
  170.  
  171.   { Collapse repeating codes }
  172.   I := 2;
  173.   while I <= Length(aKey) do
  174.     if aKey[I] = aKey[I - 1] then
  175.       Delete(aKey, I, 1)
  176.     else
  177.       Inc(I);
  178.  
  179.   if Length(aKey) < 4 then
  180.     aKey := aKey + StringofChar(' ', 4 - Length(aKey));
  181.  
  182.   Result := aKey;
  183. end;
  184.  
  185. function TForm1.Metaphone(aKey: string): string;
  186. const
  187.   MaxCodeLength = 6;
  188.   VowelSet = ['A', 'E', 'I', 'O', 'U'];
  189.   NonTransformSet = ['F', 'J', 'L', 'M', 'N', 'R'];
  190.   EIYSet = ['E', 'I', 'Y'];
  191. var
  192.   Ch: Char;
  193.   I: Integer;
  194.   KeyBuffer: array[0..256] of Char;
  195.   KeyBufLen: Integer;    { Number of chars in buffer }
  196.   Key: PChar;            { Pointer to start of string }
  197.   LastCharPos: Integer;  { Position of last char in the buffer }
  198. begin
  199.   Result := '';
  200.  
  201.   { Retain uppercase alpha characters in buffer; the buffer will
  202.     always have at least one #0 placeholder before and after the
  203.     keyword.  This avoids the need to check length bounds when
  204.     comparing previous or next letters.  }
  205.   FillChar(KeyBuffer, SizeOf(KeyBuffer), #0);
  206.   Key := @KeyBuffer[1];
  207.   KeyBufLen := 0;
  208.   for I := 1 to Length(aKey) do begin
  209.     Ch := UpCase(aKey[I]);
  210.     if Ch in ['A'..'Z'] then begin
  211.       Key[KeyBufLen] := Ch;
  212.       Inc(KeyBufLen);
  213.     end;
  214.   end;
  215.   LastCharPos := KeyBufLen - 1;
  216.  
  217.   { Transform prefixes }
  218.   if CompareMem(Key, PChar('GN'), 2) or
  219.      CompareMem(Key, PChar('KN'), 2) or
  220.      CompareMem(Key, PChar('PN'), 2) or
  221.      CompareMem(Key, PChar('AE'), 2) or
  222.      CompareMem(Key, PChar('WH'), 2) or
  223.      CompareMem(Key, PChar('WR'), 2) then
  224.     Inc(Key)
  225.   else if Key[0] = 'X' then
  226.     Key[0] := 'S';
  227.  
  228.   for I := 0 to LastCharPos do begin
  229.  
  230.     { Skip duplicating letters except for C }
  231.     if (Key[I - 1] = Key[I]) and (Key[I] <> 'C') then
  232.       Continue;
  233.  
  234.     { Retain nontransform letters }
  235.     if (Key[I] in NonTransformSet) or
  236.        ((I = 0) and (Key[I] in VowelSet)) then begin
  237.       Result := Result + Key[I];
  238.       Continue;
  239.     end;
  240.  
  241.     { Apply transforms }
  242.     case Key[I] of
  243.       'B': { retain unless within -MB }
  244.            if not ((I = LastCharPos) and (Key[I - 1] = 'M')) then
  245.              Result := Result + 'B';
  246.       'C': { drop if in -SCI-, -SCE- or -SCY- }
  247.            if not ((Key[I - 1] = 'S') and (Key[I + 1] in EIYSet)) then
  248.              { map to X if in -CIA- or -CH-}
  249.              if ((Key[I + 1] = 'I') and (Key[I + 2] = 'A')) or
  250.                 (Key[I + 1] = 'H') then
  251.                Result := Result + 'X'
  252.              else
  253.                { map to S if in -CE-, -CI- or -CY- }
  254.                if Key[I + 1] in EIYSet then
  255.                  Result := Result + 'S'
  256.                else  { otherwise K }
  257.                  Result := Result + 'K';
  258.       'D': { map to J if in -DGE-, -DGI- or -DGY- }
  259.            if (Key[I + 1] = 'G') and (Key[I + 2] in EIYSet) then
  260.              Result := Result + 'J'
  261.            else  { otherwise T }
  262.              Result := Result + 'T';
  263.       'G': { map to J if in -GE-, -GI, -GY and not GG }
  264.            if (Key[I + 1] in EIYSet) and (Key[I - 1] <> 'G') then
  265.              Result := Result + 'J'
  266.            else
  267.                     { drop if in -GH- but not at end or before a vowel }
  268.              if not ((Key[I + 1] = 'H') and (I <> LastCharPos - 1) and not (Key[I + 2] in VowelSet)) or
  269.                     { drop if in -GNED }
  270.                     ((I = LastCharPos - 3) and CompareMem(@Key[I + 1], PChar('NED'), 3)) or
  271.                     { drop if in -GN }
  272.                     ((I = LastCHarPos - 1) and (Key[I + 1] = 'N')) or
  273.                     { drop if in -DGE-, -DGI- or -DGY- }
  274.                     ((Key[I - 1] = 'D') and (Key[I + 1] in EIYSet)) then
  275.                { otherwise K }
  276.                Result := Result + 'K';
  277.       'H': { retain if before a vowel and not after C, G, P, S or T }
  278.            if (Key[I + 1] in VowelSet) and
  279.               not (Key[I - 1] in ['C', 'G', 'P', 'S', 'T']) then
  280.              Result := Result + 'H';
  281.       'K': { retain unless after C }
  282.            if Key[I - 1] <> 'C' then
  283.              Result := Result + 'K';
  284.       'P': { map to F if before H }
  285.            if Key[I + 1] = 'H' then
  286.              Result := Result + 'F'
  287.            else  { otherwise P }
  288.              Result := Result + 'P';
  289.       'Q': { map to K }
  290.            Result := Result + 'K';
  291.       'S': { map to X if in -SH-, -SIO- or -SIA- }
  292.            if (Key[I + 1] = 'H') or
  293.               ((Key[I + 1] = 'I') and (Key[I + 2] in ['O', 'A'])) then
  294.              Result := Result + 'X'
  295.            else  { otherwise S }
  296.              Result := Result + 'S';
  297.       'T': { map to X if in -TIA- or -TIO- }
  298.            if (Key[I + 1] = 'I') and (Key[I + 2] in ['O', 'A']) then
  299.              Result := Result + 'X'
  300.            else
  301.              { map to 0 (zero) if before H }
  302.              if Key[I + 1] = 'H' then
  303.                Result := Result + '0'
  304.              else
  305.                { drop if in -TCH- }
  306.                if not ((Key[I + 1] = 'C') and (Key[I + 2] = 'H')) then
  307.                  { otherwise T }
  308.                  Result := Result + 'T';
  309.       'V': { map to F }
  310.            Result := Result + 'F';
  311.       'W',
  312.       'Y': { retain if after a vowel }
  313.            if Key[I - 1] in VowelSet then
  314.              Result := Result + Key[I];
  315.       'X': { map to KS }
  316.            Result := Result + 'KS';
  317.       'Z': { map to S }
  318.            Result := Result + 'S';
  319.     end;
  320.  
  321.     { terminate if max code length is reached }
  322.     if Length(Result) = MaxCodeLength then
  323.       Break;
  324.   end;
  325. end;
  326.  
  327. procedure TForm1.ShowValue(aKey: string);
  328. begin
  329.   with Memo1.Lines do
  330.     Add(Format('%-15s %-10s %-10s',
  331.                [aKey, Soundex(aKey), Metaphone(aKey)]));
  332. end;
  333.  
  334. procedure TForm1.FormCreate(Sender: TObject);
  335. begin
  336.   with Memo1.Lines do begin
  337.     Clear;
  338.     Add(Format('%-15s %-10s %-10s',
  339.                ['NAME', 'SOUNDEX', 'METAPHONE']));
  340.   end;
  341.  
  342.   ShowValue('Smith');
  343.   ShowValue('Smythe');
  344.   ShowValue('Smit');
  345.   ShowValue('Dickson');
  346.   ShowValue('Dixon');
  347.   ShowValue('Troxell');
  348.   ShowValue('Troxel');
  349.   ShowValue('Troxwell');
  350.   ShowValue('Traxell');
  351.   ShowValue('Traxel');
  352.   ShowValue('Trachsel');
  353.   ShowValue('Troyell');
  354.   ShowValue('Troyel');
  355.   ShowValue('Trovell');
  356.   ShowValue('Trovel');
  357.   ShowValue('Tropical');
  358. end;
  359.  
  360. end.
  361.